;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
#||
			RESTRICTED RIGHTS LEGEND
				    
 Use, duplication, or disclosure by the Government is subject to
 restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
 Technical Data and Computer Software Clause at 52.227-7013 of the DOD
 FAR Supplement.
				    
				TSP (The Software Partnership)
				P.O. Box 991
				Melrose, MA 02176
				    
      Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
||#
 
(in-package :ooga)


;;; This file contains methods related to the population module.


;;; VARIABLES


(defvar *CURRENT-OPERATOR* nil "Operator being currently used")

(defvar *CURRENT-PARENTS* nil "Parents used by current operator")

(defvar *CURRENT-CHILDREN* nil "Children created by current operator")

(defvar *ADAPTIVE-DISPLAY-FLAG* t "Whether to display operator amounts")

;;; Some SAFETY checks to warn the user of the possible conflict between
;;; using Adaptive Operators with either recycling and/or operator weight
;;; interpolation.  

(defmethod INITIALIZE-INSTANCE :AFTER
	   ((module adaptive-reproduction-module) &rest ignore)
  (declare (ignore ignore))
  (if *recycle-members-flag*
      (format *standard-output*
	      "~%~%~%WARNING:  ADAPTIVE MODULE BEING USED WITH RECYCLING"))
  (if (loop for technique in (parameterization-techniques module)
	    thereis (eq 'interpolate-operator-weights
			(class-name (class-of technique))))
      (format *standard-output*
	      "~%~%~%WARNING:  ADAPTIVE MODULE BEING USED ~%WITH OPERATOR WEIGHT INTERPOLATION")))

;************************************************************

;	LINEAGE TRACKING CLASSES AND METHODS



(defmethod INITIALIZE-FOR-RUN :AFTER ((lineage-tracker lineage-tracker))
  "Initialize the lineage list"
  (setf (lineage (lineage-list lineage-tracker)) nil))


(defmethod APPLY-OPERATOR :BEFORE (operator (lineage-tracker lineage-tracker))
  "Reset pointers to operator creation and children"
  (setf *current-operator* operator
	*current-children* nil
	*current-parents* nil))


(defmethod REPRODUCE :AROUND
	   ((technique reproduction-technique)
	    (module adaptive-reproduction-module))
  "Unobtrusively set up children-parent pointers."
  (let ((children (call-next-method technique module))
	 (population-module (population-module (ga module))))
    (when children
	  (loop for child in children
		with parents = *current-parents*
		do (setf (parents child) parents))
	  (loop for parent in *current-parents*
		do (setf (children parent) children))
	  (install-lineage-data population-module
			*current-operator* children))
    (setf *current-children* children)))


(defmethod INSTALL-MEMBER :BEFORE
	   ((module adaptive-operator-module) member)
  "Unobtrusively note local delta"
	(if (and (> (current-index module)
		    (population-size module))
		 (first-member module)
		 (evaluation-better-p member (first-member module)))
	    (setf (local-delta member)
		   (abs (- (evaluation member)
			   (evaluation (first-member module)))))))


(defmethod GET-PARENT :AROUND
	   ((parent-selection-technique parent-selection-technique))
   "Track the parents"
   (let ((parent (call-next-method parent-selection-technique)))
     (setf *current-parents* (cons parent *current-parents*))
     parent))


(defmethod INSTALL-LINEAGE-DATA
	   ((module lineage-tracker) operator children)
  "Do bookkeeping and set up an alist with the operators as keys"
  (let* ((lineage-list (lineage (lineage-list module)))
	 (list (assoc operator lineage-list)))
    (if list
	(rplacd list (append children (cdr list)))
	(setf (lineage (lineage-list module))
	      (push (cons operator children) lineage-list)))
    ))



;************************************************************

;	OPERATOR ADAPTATION METHODS



(defmethod TOTAL-DELTA ((member adaptation-population-member))
  "Sum the local and inherited delta"
  (+ (local-delta member)
     (inherited-delta member)))


(defmethod INITIALIZE-FOR-RUN :AFTER ((module adaptive-operator-module))
  "Initialize the next adaptation variable"
  (setf (next-adaptation module)
	(+ (population-size module)
	   (adaptation-interval module)))
  (setf (operator-weights (reproduction-module (ga module)))
	(initial-operator-weights module)))


(defmethod INSERT-POPULATION-MEMBERS :AFTER ((module adaptive-operator-module) members)
  "Do bookkeeping on best-member deltas"
  (declare (ignore members))
  (if (>= (current-index module)
	  (next-adaptation module))
      (carry-out-adaptation module))
  )


(defmethod CARRY-OUT-ADAPTATION ((module adaptive-operator-module))
  "Modify the operator weights and set the time for the next adaptation"
  (adapt-operator-weights module)
  (setf (next-adaptation module)
	(do ((adaptation (adaptation-interval module)
			 (+ adaptation (adaptation-interval module))))
	    ((> adaptation (current-index module)) adaptation))))


(defmethod ADAPT-OPERATOR-WEIGHTS ((module adaptive-operator-module))
  "Adapt the relative weights of the operators using the procedure described in Chapter 6 of the Handbook."
  (if *adaptive-display-flag*
      (format t "~%~%Adapting weights at ~a with best value ~a:~%~a"
	      (current-index module)
	      (evaluation (first-member module))
	      (loop for weight in
			(operator-weights (reproduction-module (ga module)))
		    collect (round weight))))
  (let* ((old-weights (operator-weights (reproduction-module (ga module))))
	 (factor (/ (- 100 (adaptive-delta-amount module)) 100.0)))
    (compute-member-deltas module (get-current-members module))
    (let* ((deltas (compute-operator-deltas module))
	   (normalized-deltas
	     (normalize-total deltas
			      (adaptive-delta-amount module))))
      (do ((old old-weights (cdr old))
	   (new-weights nil)
	   (modifiers normalized-deltas (cdr modifiers)))
	  ((null old)
	   (progn (setf (operator-weights (reproduction-module (ga module)))
			(normalize-total (nreverse new-weights) 100))))
	(setf new-weights (cons (max (minimum-operator-weight module)
				     (+ (car modifiers)
					(* (car old) factor)))
				new-weights)))
      (if *adaptive-display-flag*
	  (format t "~%~a~%~a"
		  deltas
		  (loop for weight in
			    (operator-weights (reproduction-module (ga module)))
			collect (round weight))))
      )))


(defmethod GET-CURRENT-MEMBERS ((module adaptive-operator-module))
  "Get the current members of the population for adapting operator weights"
  (loop for operator-alist in (lineage (lineage-list module))
	with first-index = (- (current-index module)
			      (adaptation-window module))
	append (loop for member in (cdr operator-alist)
		     until (and (index member)
				(< (index member) first-index))
		     when (index member) collect member)))


(defmethod COMPUTE-OPERATOR-DELTAS ((module adaptive-operator-module))
  "Compute the deltas of the operators.  Assumption is that the
   deltas of the members have been computed."
  (loop for operator in (operator-list (reproduction-module (ga module)))
	collect (operator-delta module operator)))


(defmethod COMPUTE-MEMBER-DELTAS ((module adaptive-operator-module) members)
  "Compute the deltas of the members"
  (clear-member-deltas module members)
  (loop for member in members
	do (compute-inherited-delta member
				    (inherited-delta-scalar module)
				    (inherited-delta-generations module))))


(defmethod CLEAR-MEMBER-DELTAS ((module adaptive-operator-module) members)
  "Reset delta slots in members"
  (loop for x in members
	do (setf (inherited-delta x) 0)))



(defmethod COMPUTE-LOCAL-DELTA ((member adaptation-population-member) more-is-better?)
  "Compute the difference between the evaluation and the best parent's evaluation"
  (if more-is-better? 
      (max 0 (- (evaluation member)
		(loop for parent in (parents member)
		      maximize (evaluation parent))))
      (max 0 (- (loop for parent in (parents member)
		      minimize (evaluation parent))
		(evaluation member)))))


(defmethod COMPUTE-INHERITED-DELTA
	   ((member adaptation-population-member) scalar generations)
  "Pass back part of the delta to preceding generations, damping the amount by 
   the scalar and apportioning it among the parents equably"
  (if (and (parents member) (not (= (local-delta member) 0)))
      (loop for parent in (parents member)
	    with amount = (* scalar
			     (/ (local-delta member)
				(float (length (parents member)))))
	    do (add-inherited-delta parent amount scalar (1- generations)))))


(defmethod ADD-INHERITED-DELTA
	   ((member adaptation-population-member) amount scalar generations)
  "Pass the inherited delta back to progenitors."
  (if (> generations 0)
      (progn (setf (inherited-delta member) (+ (inherited-delta member) amount))
	     (if (parents member)
		 (loop for parent in (parents member)
		       with new-amount = (* scalar
					    (/ amount
					       (float
						 (length (parents member)))))
		       do (add-inherited-delta
			    parent new-amount scalar (1- generations)))))))


(defmethod OPERATOR-DELTA ((module adaptive-operator-module) operator)
  "Get the average total delta for the operator"
  (let* ((first-index (- (current-index module)
			      (adaptation-window module)))
	 (current-members
	   (loop for member in (cdr (assoc operator
					   (lineage (lineage-list module))))
		 until (and (index member)
			    (< (index member) first-index))
		 when (index member) collect member)))
    (if current-members
	(/ (loop for member in current-members
		 summing (total-delta member))
	   (float (length current-members)))
	0)))


;************************************************************

;	ADAPTIVE OPERATOR WEIGHT TRACING


;;;Used to trace weight history over multiple runs.

(defclass TRACE-OPERATOR-WEIGHTS (adaptive-operator-module)
     ((OPERATOR-WEIGHT-HISTORY :initarg :operator-weight-history
			       :initform nil :accessor operator-weight-history)
      ))


(defmethod INITIALIZE-POPULATION :after ((module trace-operator-weights)) 
  "Maintain the operator weight history slot"
  (setf (operator-weight-history module)
	(push (list (list (current-index module)
			  (operator-weights
			    (reproduction-module (ga module)))))
	      (operator-weight-history module))))


(defmethod ADAPT-OPERATOR-WEIGHTS :AFTER ((module trace-operator-weights))
  "Add information to the operator weight history slot"
  (push (list (current-index module)
	      (operator-weights
		(reproduction-module (ga module))))
	(car (operator-weight-history module))))


(defmethod AVERAGE-OPERATOR-WEIGHTS ((module trace-operator-weights))
  "Find average weights at different run stages"
  (loop with history = (operator-weight-history module)
	for stage in (car history)
	collect (average-weights-at-stage stage history)))


;************************************************************

;	ADAPTIVE OPERATOR WEIGHT INITIALIZATION 


(defvar *INITIAL-DELTAS* nil "Deltas for successive populations")


;;;THIS CLASS IS TO BE COMBINED WITH GENETIC ALGORITHM CLASSES.
(defclass ADAPT-INITIAL-OPERATOR-WEIGHTS ()
     ())


(defmethod FIND-INITIAL-OPERATOR-WEIGHTS
	   ((ga adapt-initial-operator-weights)
	    &optional (cycles 10)
	    (number-to-generate 200))
  (initialize-for-run ga)
  (setf *initial-deltas*
  (loop repeat cycles
	collect (adapt-initial-operator-weights
		  ga number-to-generate)))
  (display-final-average ga *initial-deltas*))


(defmethod DISPLAY-FINAL-AVERAGE
	   ((ga adapt-initial-operator-weights) final-deltas)
  (format *standard-output*
	  "~%~%~%AVERAGE DELTA FOR ~a CYCLES:" (length final-deltas))
  (loop for deltas in final-deltas do (print deltas))
  (let ((initial-weights
	  (normalize (parallel-average
		       (loop for deltas in final-deltas
				 collect (normalize deltas
						    (/ 100.0 (length deltas)))))
		     (/ 100.0 (length (car final-deltas))))))
    (format *standard-output*
	    "~%~%INITIAL OPERATOR WEIGHTS BASED ON AVERAGE DELTA:~%  ~a"
	    initial-weights)
    initial-weights))


;;; Algorithm for finding initial weights.  Superior
;;; to that in the Handbook.  Replaces the algorithm in the Handbook.

(defmethod ADAPT-INITIAL-OPERATOR-WEIGHTS
	   ((ga adapt-initial-operator-weights)
	    number-to-run)
  (initialize-population (population-module ga))
  (format t "~%~%Best eval = ~a"
	  (evaluation (first-member (population-module ga))))
  (let ((population-module (population-module ga))
	(reproduction-module (reproduction-module ga)))
    (if *adaptive-display-flag*
	(format *standard-output*
	    "~%~%Deltas for ~a new members:" number-to-run))
    (loop for operator in
	      (operator-list reproduction-module)
	  for new-members = (n-new-members number-to-run
					   operator
					   population-module)
	  with deltas = nil
	  do (loop for member in new-members
		   do (setf (evaluation member)
			    (evaluate-member
			      (evaluator (evaluation-module ga))
			      member)))
	     (let ((new-deltas
		     (/ (loop for member in new-members
			      summing (if (evaluation-better-p
					    member
					    (first-member population-module))
					  (abs (- (evaluation member)
						  (evaluation
						    (first-member
						      population-module))))
					  0))
			(float (length new-members)))))
	       (if *adaptive-display-flag*
		   (format *standard-output* "~%Deltas for ~a = ~a"
		       (class-name (class-of operator)) new-deltas))
	       (setf deltas (cons new-deltas deltas)))
	  finally (return (reverse deltas)))))


(defmethod N-NEW-MEMBERS
	   (n (operator ga-operator) (population-module basic-population-module))
  (loop with new-chromosomes = nil
	until (>= (length new-chromosomes) n)
	do (setf new-chromosomes
		 (append (apply-operator operator population-module)
			 new-chromosomes))
	finally (return
		  (loop for chromosome in new-chromosomes
			for member =
			    (create-population-member
			      (initialization-technique population-module)
			      (representation-technique population-module))
			with new-members = nil
			do (setf (chromosome member) chromosome
				 new-members (cons member new-members))
			finally (return new-members)))))
